home *** CD-ROM | disk | FTP | other *** search
/ Collection of Tools & Utilities / Collection of Tools and Utilities.iso / clipper / rfntlb10.zip / RFNTDEMO.PRG < prev    next >
Text File  |  1994-01-02  |  12KB  |  433 lines
  1. *--------------------------------------------------------------------------
  2. * RFntDemo.PRG - Program to demonstrate the use of the functions
  3. *                in the Clipper Library RFntLib
  4. *
  5. * Used functions :
  6. *
  7. *    R_DefFnt  ()  - Install default ROM font (EGA or VGA)
  8. *    R_EGAFnt  ()  - Install one of the INTERNAL (built-in) EGA fonts
  9. *    R_EGAName ()  - Retrieve the name of an INTERNAL (built-in) EGA font
  10. *    R_FntFile ()  - Load an EXTERNAL EGA or VGA font from a disk file
  11. *    R_FntName ()  - Retrieve the name of the current font
  12. *    R_FntNr   ()  - Retrieve the number of the current font
  13. *       R_IsEGAFl ()  - Determine if an EGA card is present
  14. *       R_IsVGAFl ()  - Determine if an VGA card is present
  15. *       R_MaxFnt  ()  - Determine the number of INTERNAL (built-in) fonts
  16. *    R_VGAFnt  ()  - Install one of the INTERNAL (built-in) VGA fonts
  17. *    R_VGAName ()  - Retrieve the name of an INTERNAL (built-in) VGA font
  18. *
  19. * This demo has been written for Clipper version 5.xx
  20. *
  21. * Compile    :    CLIPPER RFNTDEMO -N
  22. *
  23. * Link       :    RTLINK   file RFNTDEMO lib RFNTLIB    - or -
  24. *        BLINKER  file RFNTDEMO lib RFNTLIB    - or -
  25. *        EXOSPACE file RFNTDEMO lib RFNTEXO exo pack int10
  26. *
  27. * Syntax     :  RFNTDEMO
  28. *--------------------------------------------------------------------------
  29. * Date       :  02/01/94
  30. *--------------------------------------------------------------------------
  31. * Author     :  Ing. R.P.B. van Gelder
  32. *               Binnenwiertzstraat 27
  33. *               5615 HG  EINDHOVEN
  34. *            THE NETHERLANDS
  35. *
  36. * E-Mail     :  Internet: RCROLF@urc.tue.nl
  37. *               BitNet  : RCROLF@heitue5
  38. *--------------------------------------------------------------------------
  39. * (c) 1994  Rolf van Gelder, All rights reserved
  40. *--------------------------------------------------------------------------
  41.  
  42. *--------------------------------------------------------------------------
  43. * STANDARD CLIPPER HEADER FILES
  44. *--------------------------------------------------------------------------
  45. #include "Inkey.ch"
  46. #include "Directry.ch"
  47.  
  48. *--------------------------------------------------------------------------
  49. * INCLUDE THE RFNTLIB HEADER FILE
  50. *--------------------------------------------------------------------------
  51. #include "RFNTLIB.CH"
  52.  
  53. *--------------------------------------------------------------------------
  54. * CONSTANTS
  55. *--------------------------------------------------------------------------
  56. #define    CRLF    CHR(13)+CHR(10)
  57.  
  58. *--------------------------------------------------------------------------
  59. * STATIC VARIABLES
  60. *--------------------------------------------------------------------------
  61. *-- Flag which indicates where the PC has an EGA or VGA card
  62. STATIC    lIsVGA
  63.  
  64. *-- Initialize error text array using the header file (RFntLib.CH)
  65. STATIC    aErrMsg := FL_ERRMSG
  66.  
  67. *--------------------------------------------------------------------------
  68. * STATIC CODEBLOCKS
  69. *--------------------------------------------------------------------------
  70.  
  71. *-- "Hit any key" message
  72. STATIC    bHitKey := { || DevPos (MaxRow()-1,32), DevOut('Hit any key ....'),;
  73.                         InKey (0) }
  74.  
  75. *-- Header line (with clear screen)
  76. STATIC    bHeader := { || Scroll (), ;
  77.                         DispMsg ( 0, 'RFntDemo: Demo program for ' + ;
  78.                         'RFntLib v1.0                (C) 1994  ' + ;
  79.                         'Rolf van Gelder', 'W+/BG' ) }
  80.  
  81. *--------------------------------------------------------------------------
  82. *
  83. *                          M A I N   P R O G R A M
  84. *
  85. *--------------------------------------------------------------------------
  86. FUNCTION RFntDemo
  87.  
  88. *-- Array with menu choices
  89. LOCAL    aMenu    := { ;
  90.    'Load an INTERNAL screen font .... R_VGAFnt(), R_EGAFnt()', ;
  91.    'Load an EXTERNAL screen font ............... R_FntFile()', ;
  92.    'Install the DEFAULT ROM font ................ R_DefFnt()', ;
  93.    'Display the NAME   of the current font ..... R_FntName()', ;
  94.    'Display the NUMBER of the current font ....... R_FntNr()', ;
  95.    'Display the current CHARACTER SET', ;
  96.    'Symbols & Icons in the RSymbol1 & RSymbol2 fonts', ;
  97.    'End of Demo' }
  98.  
  99. LOCAL    nChoice  := 1            && Menu choice made
  100.  
  101. LOCAL    cOldCol                && Screen color
  102.  
  103. LOCAL    nIntFont            && Number of internal font
  104. LOCAL    nFonts                && Number of internal fonts
  105. LOCAL    nCnt                && Counter
  106.  
  107. LOCAL    aIntFnts := {}            && Internal font names
  108.  
  109. LOCAL    nRetCode            && Return code
  110.  
  111. *-- Set Color to Bright While on Blue
  112. SetColor ( 'W+/B' )
  113.  
  114. *-- Determine if an EGA card is present
  115. IF !R_IsEGAFl ()
  116.  
  117.    *-- No EGA nor VGA
  118.    Alert ( 'I am sorry ... EGA adapter or better required !' )
  119.    
  120.    RETURN nil
  121.    
  122. ENDIF
  123.  
  124. *-- Determine if an VGA card is present and save it to a static var
  125. lIsVGA := R_IsVGAFl ()
  126.  
  127. *-- Determine the number of INTERNAL (built-in) fonts
  128. nFonts := R_MaxFnt ()
  129.  
  130. *-- Create an array containing the names of the INTERNAL fonts
  131. FOR nCnt := 1 TO nFonts
  132.  
  133.    IF lIsVGA
  134.       *-- Add the name of an INTERNAL VGA font
  135.       AAdd ( aIntFnts, R_VGAName ( nCnt ) )
  136.  
  137.    ELSE
  138.       *-- Add the name of an INTERNAL EGA font
  139.       AAdd ( aIntFnts, R_EGAName ( nCnt ) )
  140.  
  141.    ENDIF
  142.  
  143. NEXT
  144.  
  145. *--------------------------------------------------------------------------
  146. *                            M A I N   L O O P
  147. *--------------------------------------------------------------------------
  148. DO WHILE .t.
  149.  
  150.    *-- Display header lines
  151.    Eval ( bHeader )
  152.  
  153.    *-- Display footer font name
  154.    DispMsg ( 24, '<Current font: ' + Trim ( R_FntName () ) + '>', 'W+/BG' )
  155.  
  156.    DevPos ( 3, 31 )
  157.    DevOut ( '-+- MAIN  MENU -+-' )
  158.  
  159.    *-- Draw box
  160.    Scroll  ( 5, 10, 14, 69 )
  161.    DispBox ( 5, 10, 14, 69, 1 )
  162.  
  163.    *-- Display main menu and get a choice
  164.    nChoice := AChoice ( 6, 12, 13, 67, aMenu, , , nChoice )
  165.  
  166.    IF LastKey () = K_ESC .or. nChoice = Len ( aMenu )
  167.       *-- Canceled
  168.       EXIT
  169.    ENDIF
  170.    
  171.    DO CASE
  172.    CASE nChoice = 1
  173.       *-- INTERNAL FONT
  174.  
  175.       cOldCol := SetColor ( 'W+/RB' )
  176.  
  177.       DispMsg ( 24, 'CHOOSE THE INTERNAL FONT FILE TO LOAD (Esc=Cancel)' )
  178.  
  179.       *-- Choose a font file
  180.       DispBox ( 7, 22, 7 + R_MaxFnt () + 1, 57, 1 )
  181.  
  182.       nIntFont := AChoice ( 8, 23, 8 + R_MaxFnt() - 1, 56, aIntFnts )
  183.  
  184.       SetColor ( cOldCol )
  185.  
  186.       IF LastKey () = K_RETURN
  187.  
  188.          nRetCode := R_VGAFnt ( nIntFont )
  189.  
  190.          IF nRetCode != FL_OKAY
  191.             *-- Display error message, using pre-defined array
  192.             Alert ( aErrMsg [nRetCode] )
  193.          ENDIF
  194.  
  195.       ENDIF
  196.  
  197.    CASE nChoice = 2
  198.       *-- LOAD AN EXTERNAL FONT FROM DISK
  199.  
  200.       LoadExtFnt ()
  201.       
  202.    CASE nChoice = 3
  203.       *-- INSTALL DEFAULT ROM FONT (EGA OR VGA)
  204.  
  205.       R_DefFnt ()
  206.       
  207.    CASE nChoice = 4
  208.       *-- GET CURRENT FONT NAME
  209.  
  210.       Alert ( 'The NAME of the current font = ' + R_FntName () )
  211.  
  212.    CASE nChoice = 5
  213.       *-- GET THE NUMBER OF THE CURRENT FONT
  214.  
  215.       Alert ( 'The NUMBER of the current font = ' + ;
  216.          LTrim ( Str ( R_FntNr () ) ) )
  217.  
  218.    CASE nChoice = 6
  219.       *-- SHOW CHARACTER SET
  220.  
  221.       ShowSet ()
  222.  
  223.    CASE nChoice = 7
  224.       *-- SYMBOL/ICON DEMO
  225.  
  226.       SymbolDemo ()
  227.  
  228.    ENDCASE
  229.    
  230. ENDDO
  231.  
  232. *-- INSTALL DEFAULT ROM FONT (EGA OR VGA)
  233. R_DefFnt ()
  234.  
  235. *-- Clear screen
  236. Scroll ()
  237.  
  238. RETURN nil
  239.  
  240.  
  241. *--------------------------------------------------------------------------
  242. *
  243. *                    LOAD AN EXTERNAL FONT FROM DISK
  244. *
  245. *--------------------------------------------------------------------------
  246. STATIC FUNCTION LoadExtFnt
  247.  
  248. LOCAL    aDirectory := {}        && Directory array
  249. LOCAL    aFileList  := {}        && File list array
  250. LOCAL    nFiles                && Number of font file in directory
  251. LOCAL    nChoice                && Choice
  252. LOCAL    nCnt                && Counter
  253. LOCAL    cFntFile            && Name of chosen font file
  254. LOCAL    cOldCol                && Screen color
  255. LOCAL    nRetCode            && Return code R_FntFile
  256.  
  257. *-- Get the complete directory to aDirectory
  258. aDirectory := Directory ( '*.*' )
  259.  
  260. *-- Number of files in the current directory
  261. nFiles     := Len ( aDirectory )
  262.  
  263. IF nFiles < 1
  264.  
  265.    Alert ( 'No files found in current directory ...' )
  266.  
  267.    RETURN nil
  268.  
  269. ENDIF
  270.  
  271. *-- Compose a file list
  272. FOR nCnt := 1 TO nF